home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 2: CDPD 1 / Almathera Ten on Ten - Disc 2: CDPD 1.iso / pd / 201-225 / 201 / draco / src / winter.d < prev    next >
Text File  |  1995-03-13  |  11KB  |  474 lines
  1. #drinc:exec/miscellaneous.g
  2. #drinc:exec/ports.g
  3. #drinc:exec/tasks.g
  4. #drinc:intuition/miscellaneous.g
  5. #drinc:intuition/intuitionbase.g
  6. #drinc:intuition/screen.g
  7. #drinc:intuition/window.g
  8. #drinc:graphics/gfx.g
  9. #drinc:graphics/view.g
  10. #drinc:graphics/rastport.g
  11. #drinc:libraries/dos.g
  12. #drinc:libraries/dosextens.g
  13. #drinc:libraries/layers.g
  14.  
  15. /*
  16.  * Winter - a small display hack by Chris Gray - October 17, 1987.
  17.  */
  18.  
  19. uint
  20.     MAX_FLAKES = 200,                /* size of flake array */
  21.     MAX_TRIES = 100,                /* search for empty spot */
  22.     TITLE_HEIGHT = 10,                /* snow below title bars */
  23.     STICK_PERCENT = 5;                /* percent that stick */
  24.  
  25. ulong HI_PRIORITY = +127;
  26.  
  27. type Flake_t = struct {
  28.     *Flake_t fl_prev, fl_next;
  29.     uint fl_x, fl_y;
  30. };
  31.  
  32. uint Seed;                    /* for random number gen. */
  33.  
  34. [MAX_FLAKES] Flake_t Flake;
  35. *Flake_t FreeFlakes, FlakeHead, FlakeTail;
  36.  
  37. *IntuitionBase_t IntuitionBase;         /* needed for checking */
  38. *Task_t ThisTask;                /* so we can use SetTaskPri */
  39. ulong IBaseLock;                /* held when 'snow' returns */
  40.  
  41. /*
  42.  * random - return a random number 0 - passed range.
  43.  */
  44.  
  45. proc random(uint rang)uint:
  46.  
  47.     if rang = 0 then
  48.     0
  49.     else
  50.     Seed := Seed * 17137 + 4287;
  51.     Seed := (Seed >> 8) >< (Seed << 8);
  52.     Seed % rang
  53.     fi
  54. corp;
  55.  
  56. /*
  57.  * initFlakes - intialize the Flake array to be all free flakes.
  58.  */
  59.  
  60. proc initFlakes()void:
  61.     register uint i;
  62.  
  63.     for i from 0 upto MAX_FLAKES - 1 do
  64.     Flake[i].fl_next := &Flake[i + 1];
  65.     od;
  66.     Flake[MAX_FLAKES - 1].fl_next := nil;
  67.     FreeFlakes := &Flake[0];
  68.     FlakeHead := nil;
  69.     FlakeTail := nil;
  70. corp;
  71.  
  72. /*
  73.  * addFlake - make a new flake at the given position.
  74.  */
  75.  
  76. proc addFlake(uint x, y)void:
  77.     register *Flake_t fl;
  78.  
  79.     fl := FreeFlakes;
  80.     if fl ~= nil then
  81.     FreeFlakes := fl*.fl_next;
  82.     fl*.fl_x := x;
  83.     fl*.fl_y := y;
  84.     fl*.fl_next := nil;
  85.     fl*.fl_prev := FlakeTail;
  86.     if FlakeTail = nil then
  87.         FlakeHead := fl;
  88.     else
  89.         FlakeTail*.fl_next := fl;
  90.     fi;
  91.     FlakeTail := fl;
  92.     fi;
  93. corp;
  94.  
  95. /*
  96.  * deleteFlake - delete a flake that has died, etc.
  97.  */
  98.  
  99. proc deleteFlake(register *Flake_t fl)*Flake_t:
  100.     register *Flake_t t;
  101.  
  102.     t := fl;
  103.     fl := t*.fl_next;
  104.     if fl = nil then
  105.     FlakeTail := t*.fl_prev;
  106.     else
  107.     fl*.fl_prev := t*.fl_prev;
  108.     fi;
  109.     if t*.fl_prev = nil then
  110.     FlakeHead := fl;
  111.     else
  112.     t*.fl_prev*.fl_next := fl;
  113.     fi;
  114.     t*.fl_next := FreeFlakes;
  115.     FreeFlakes := t;
  116.     fl
  117. corp;
  118.  
  119. /*
  120.  * cloneRastPort - make a copy of a RastPort_t, but one that has all of its
  121.  *    modes, etc. default values.
  122.  */
  123.  
  124. proc cloneRastPort(*RastPort_t rpOld, rpNew)void:
  125.  
  126.     rpNew* := rpOld*;
  127.     SetDrMd(rpNew, JAM1);
  128.     SetDrPt(rpNew, 0xffff);
  129.     SetWrMsk(rpNew, 0xff);
  130. corp;
  131.  
  132. /*
  133.  * snow - everything is fine - make it snow. Return 'true' if we filled up
  134.  *    the window, 'false' if it has gone away on us.
  135.  */
  136.  
  137. proc snow(*Window_t window; ushort colour)bool:
  138.     RastPort_t rastPort;
  139.     register *Flake_t fl;
  140.     register *Screen_t sc;
  141.     register *Window_t w;
  142.     register uint x, y, newX;
  143.     ulong oldPriority;
  144.     uint width, height, flakeCount, r, newY, oldColour;
  145.     bool first, foundWindow, flakeGone;
  146.  
  147.     /* we want WHITE snowflakes, but be nice and put it back when done. */
  148.  
  149.     oldColour := GetRGB4(window*.w_WScreen*.sc_ViewPort.vp_ColorMap, colour);
  150.     SetRGB4(&window*.w_WScreen*.sc_ViewPort, colour, 0xf, 0xf, 0xf);
  151.  
  152.     flakeCount := 0;
  153.     first := true;
  154.  
  155.     /* NOTE: we enter this loop with IntuitionBase locked */
  156.  
  157.     while
  158.     foundWindow := false;
  159.     sc := IntuitionBase*.ib_FirstScreen;
  160.     while sc ~= nil do
  161.         w := sc*.sc_FirstWindow;
  162.         while w ~= nil do
  163.         if w = window then
  164.             foundWindow := true;
  165.         fi;
  166.         w := w*.w_NextWindow;
  167.         od;
  168.         sc := sc*.sc_NextScreen;
  169.     od;
  170.     (flakeCount ~= 0 or first) and foundWindow
  171.     do
  172.     first := false;
  173.     cloneRastPort(window*.w_RPort, &rastPort);
  174.  
  175.     /* The following four lines seem to be about the only way I can be
  176.        sure the window is still there, but lock it's layer so that the
  177.        size of it can't be changed while I'm playing with it. Trapping
  178.        'CloseWindow' calls may not work, since the WorkBench and other
  179.        internal window handlers (console device?) may not go through
  180.        the library vector. */
  181.  
  182.     oldPriority := SetTaskPri(ThisTask, HI_PRIORITY);
  183.     UnlockIBase(IBaseLock);
  184.     LockLayer(0, rastPort.rp_Layer);
  185.     ignore SetTaskPri(ThisTask, oldPriority);
  186.  
  187.     width := window*.w_Width - 1;
  188.     height := window*.w_Height - 1;
  189.  
  190.     /* loop through all the flakes currently falling */
  191.  
  192.     fl := FlakeHead;
  193.     while fl ~= nil do
  194.         x := fl*.fl_x;
  195.         y := fl*.fl_y;
  196.  
  197.         /* Remember, the window could have shrunk since we last looked at
  198.            this flake. */
  199.  
  200.         if x > width or y >= height then
  201.         fl := deleteFlake(fl);
  202.         flakeCount := flakeCount - 1;
  203.         else
  204.         newX := x;
  205.         if x = 0 then
  206.             if random(3) = 0 then
  207.             newX := x + 1;
  208.             fi;
  209.         elif x = width then
  210.             if random(3) = 0 then
  211.             newX := x - 1;
  212.             fi;
  213.         else
  214.             r := random(4);
  215.             if r = 0 then
  216.             newX := x - 1;
  217.             elif r = 1 then
  218.             newX := x + 1;
  219.             fi;
  220.         fi;
  221.         newY := y + 1;
  222.         flakeGone := false;
  223.         if ReadPixel(&rastPort, newX, newY) ~= 0 then
  224.             if random(100) < STICK_PERCENT then
  225.             flakeGone := true;
  226.             elif ReadPixel(&rastPort, x, newY) = 0 then
  227.             newX := x;
  228.             elif x ~= 0 and ReadPixel(&rastPort, x - 1, newY) = 0 then
  229.             newX := x - 1;        /* bias!!! */
  230.             elif x ~= width and
  231.             ReadPixel(&rastPort, x + 1, newY) = 0
  232.             then
  233.             newX := x + 1;
  234.             else
  235.             flakeGone := true;
  236.             fi;
  237.         fi;
  238.         if flakeGone then
  239.             /* nowhere for the flake to go - just leave it here */
  240.             fl := deleteFlake(fl);
  241.             flakeCount := flakeCount - 1;
  242.         else
  243.             /* move the flake */
  244.             SetAPen(&rastPort, 0);
  245.             ignore WritePixel(&rastPort, x, y);
  246.             SetAPen(&rastPort, colour);
  247.             ignore WritePixel(&rastPort, newX, newY);
  248.             fl*.fl_x := newX;
  249.             fl*.fl_y := newY;
  250.             fl := fl*.fl_next;
  251.         fi;
  252.         fi;
  253.     od;
  254.  
  255.     /* make a new flake if we are below our desired count */
  256.  
  257.     if flakeCount < make(width, ulong) * height / 200 and FreeFlakes ~= nil
  258.     then
  259.         y := 0;
  260.         while
  261.         x := random(width - 1) + 1;
  262.         ReadPixel(&rastPort, x, TITLE_HEIGHT) ~= 0 and y ~= MAX_TRIES
  263.         do
  264.         y := y + 1;
  265.         od;
  266.         if y ~= MAX_TRIES then
  267.         SetAPen(&rastPort, colour);
  268.         ignore WritePixel(&rastPort, x, TITLE_HEIGHT);
  269.         addFlake(x, TITLE_HEIGHT);
  270.         flakeCount := flakeCount + 1;
  271.         fi;
  272.     fi;
  273.  
  274.     UnlockLayer(rastPort.rp_Layer);
  275.     Delay(1);        /* let others at IntuitionBase */
  276.     IBaseLock := LockIBase(0);
  277.  
  278.     od;
  279.  
  280.     /* clean up in case we exited because our window went away */
  281.  
  282.     fl := FlakeHead;
  283.     while fl ~= nil do
  284.     fl := deleteFlake(fl);
  285.     od;
  286.  
  287.     if foundWindow then
  288.     /* restore the snowflake colour */
  289.     SetRGB4(&window*.w_WScreen*.sc_ViewPort, colour,
  290.         (oldColour >> 8) & 0xf,
  291.         (oldColour >> 4) & 0xf,
  292.         oldColour & 0xf);
  293.     fi;
  294.  
  295.     /* note: this return result is valid since we still have IntuitionBase
  296.        locked */
  297.  
  298.     foundWindow
  299. corp;
  300.  
  301. /*
  302.  * trySnowing - return 0 if we cannot snow in this window for some reason.
  303.  *        If we can snow, return the pen colour to use for flakes.
  304.  */
  305.  
  306. proc trySnowing(register *Window_t window)ushort:
  307.     register *RastPort_t rastPort;
  308.     *Layer_t layer;
  309.     *Screen_t screen;
  310.     *BitMap_t bitMap;
  311.     register *ColorMap_t colorMap;
  312.     register uint i, x, count;
  313.     uint depth, whitest;
  314.     ushort colour;
  315.  
  316.     /* if we changed this testing a bit, we could snow on the WorkBench's
  317.        backdrop instead of inside its windows */
  318.  
  319.     rastPort := window*.w_RPort;
  320.     if rastPort = nil or window*.w_Flags & BACKDROP ~= 0 then
  321.     0
  322.     else
  323.     bitMap := rastPort*.rp_BitMap;
  324.     layer := rastPort*.rp_Layer;
  325.     if bitMap = nil or layer = nil then
  326.         0
  327.     else
  328.         screen := window*.w_WScreen;
  329.         depth := bitMap*.bm_Depth;
  330.         if screen = nil or depth = 0 then
  331.         0
  332.         else
  333.         colorMap := screen*.sc_ViewPort.vp_ColorMap;
  334.         if colorMap = nil then
  335.             0
  336.         else
  337.             count := colorMap*.cm_Count;
  338.             if count <= 1 then
  339.             0
  340.             else
  341.  
  342.             /* don't snow using the background colour */
  343.  
  344.             if count > 1 << depth then
  345.                 count := 1 << depth;
  346.             fi;
  347.             whitest := 1;
  348.             for i from 1 upto count - 1 do
  349.                 x := GetRGB4(colorMap, i);
  350.                 x := (x >> 8) & 0xf + (x >> 4) & 0xf + x & 0xf;
  351.                 if x > whitest then
  352.                 whitest := x;
  353.                 colour := i;
  354.                 fi;
  355.             od;
  356.             i := 0;
  357.             while
  358.                 x := random(window*.w_Width - 2) + 1;
  359.                 ReadPixel(rastPort, x, TITLE_HEIGHT) ~= 0 and
  360.                 i ~= MAX_TRIES
  361.             do
  362.                 i := i + 1;
  363.             od;
  364.             if i = MAX_TRIES then
  365.                 0
  366.             else
  367.                 colour
  368.             fi
  369.             fi
  370.         fi
  371.         fi
  372.     fi
  373.     fi
  374. corp;
  375.  
  376. /*
  377.  * main - open libraries, handle WorkBench, chase windows.
  378.  */
  379.  
  380. proc main()void:
  381.     *char MESSAGE =
  382.     "Please use 'Run' to run this program in the background.\n";
  383.     uint MESSAGE_LENGTH = 56;
  384.     register *Screen_t screen;
  385.     register *Window_t window;
  386.     *Process_t thisProcess;
  387.     *Message_t wbMessage;
  388.     DateStamp_t ds;
  389.     ushort colour;
  390.     bool foundOne, fromWorkBench, abort;
  391.  
  392.     if OpenExecLibrary(0) ~= nil then
  393.     IntuitionBase := OpenIntuitionLibrary(0);
  394.     if IntuitionBase ~= nil then
  395.         if OpenGraphicsLibrary(0) ~= nil then
  396.         if OpenDosLibrary(0) ~= nil then
  397.             if OpenLayersLibrary(0) ~= nil then
  398.             abort := false;
  399.             ThisTask := FindTask(nil);
  400.             thisProcess := pretend(ThisTask, *Process_t);
  401.             if thisProcess*.pr_CLI = 0 then
  402.                 /* running from WorkBench */
  403.                 fromWorkBench := true;
  404.                 wbMessage := WaitPort(&thisProcess*.pr_MsgPort);
  405.                 wbMessage := GetMsg(&thisProcess*.pr_MsgPort);
  406.             else
  407.                 /* running from CLI */
  408.                 fromWorkBench := false;
  409.                 if IsInteractive(Input()) then
  410.                 ignore Write(Output(), MESSAGE,MESSAGE_LENGTH);
  411.                 abort := true;
  412.                 fi;
  413.             fi;
  414.  
  415.             if not abort then
  416.                 DateStamp(&ds);
  417.                 Seed := (ds.ds_Minute >< ds.ds_Tick) | 1;
  418.                 initFlakes();
  419.  
  420.                 IBaseLock := LockIBase(0);
  421.                 while
  422.                 foundOne := false;
  423.                 screen := IntuitionBase*.ib_FirstScreen;
  424.                 while screen ~= nil do
  425.                     window := screen*.sc_FirstWindow;
  426.                     while window ~= nil do
  427.                     colour := trySnowing(window);
  428.                     if colour ~= 0 then
  429.                         foundOne := true;
  430.                         if snow(window, colour) then
  431.                         window := window*.w_NextWindow;
  432.                         else
  433.                         /* rescan at first screen */
  434.                         screen := nil;
  435.                         window := nil;
  436.                         fi;
  437.                     else
  438.                         window := window*.w_NextWindow;
  439.                     fi;
  440.                     od;
  441.                     if screen ~= nil then
  442.                     screen := screen*.sc_NextScreen;
  443.                     fi;
  444.                 od;
  445.                 foundOne
  446.                 do
  447.                 od;
  448.                 UnlockIBase(IBaseLock);
  449.             fi;
  450.  
  451.             if fromWorkBench then
  452.  
  453.                 /* this is pretty hokey, but this is what the
  454.                    example in the RKM has. There is no matching
  455.                    'Permit' for the 'Forbid'. I will assume that
  456.                    when this task exits, the 'Permit' will
  457.                    magically happen. */
  458.  
  459.                 Forbid();
  460.                 ReplyMsg(wbMessage);
  461.             fi;
  462.  
  463.             CloseLayersLibrary();
  464.             fi;
  465.             CloseDosLibrary();
  466.         fi;
  467.         CloseGraphicsLibrary();
  468.         fi;
  469.         CloseIntuitionLibrary();
  470.     fi;
  471.     CloseExecLibrary();
  472.     fi;
  473. corp;
  474.